home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / calendar / diary-lib.el.z / diary-lib.el
Encoding:
Text File  |  1998-05-21  |  89.4 KB  |  1,939 lines
  1. ;;; diary-lib.el --- diary functions.
  2.  
  3. ;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; This collection of functions implements the diary features as described
  27. ;; in calendar.el.
  28.  
  29. ;; Comments, corrections, and improvements should be sent to
  30. ;;  Edward M. Reingold               Department of Computer Science
  31. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  32. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  33. ;;                                   Urbana, Illinois 61801
  34.  
  35. ;;; Code:
  36.  
  37. (require 'calendar)
  38.  
  39. ;;;###autoload
  40. (defun diary (&optional arg)
  41.   "Generate the diary window for ARG days starting with the current date.
  42. If no argument is provided, the number of days of diary entries is governed
  43. by the variable `number-of-diary-entries'.  This function is suitable for
  44. execution in a `.emacs' file."
  45.   (interactive "P")
  46.   (let ((d-file (substitute-in-file-name diary-file))
  47.         (date (calendar-current-date)))
  48.     (if (and d-file (file-exists-p d-file))
  49.         (if (file-readable-p d-file)
  50.             (list-diary-entries
  51.              date
  52.              (cond
  53.               (arg (prefix-numeric-value arg))
  54.               ((vectorp number-of-diary-entries)
  55.                (aref number-of-diary-entries (calendar-day-of-week date)))
  56.               (t number-of-diary-entries)))
  57.         (error "Your diary file is not readable!"))
  58.       (error "You don't have a diary file!"))))
  59.  
  60. (defun view-diary-entries (arg)
  61.   "Prepare and display a buffer with diary entries.
  62. Searches the file named in `diary-file' for entries that
  63. match ARG days starting with the date indicated by the cursor position
  64. in the displayed three-month calendar."
  65.   (interactive "p")
  66.   (let ((d-file (substitute-in-file-name diary-file)))
  67.     (if (and d-file (file-exists-p d-file))
  68.         (if (file-readable-p d-file)
  69.             (list-diary-entries (calendar-cursor-to-date t) arg)
  70.           (error "Diary file is not readable!"))
  71.       (error "You don't have a diary file!"))))
  72.  
  73. (defun view-other-diary-entries (arg diary-file)
  74.   "Prepare and display buffer of diary entries from an alternative diary file.
  75. Prompts for a file name and searches that file for entries that match ARG
  76. days starting with the date indicated by the cursor position in the displayed
  77. three-month calendar."
  78.   (interactive
  79.    (list (cond ((null current-prefix-arg) 1)
  80.                ((listp current-prefix-arg) (car current-prefix-arg))
  81.                (t current-prefix-arg))
  82.          (setq diary-file (read-file-name "Enter diary file name: "
  83.                                           default-directory nil t))))
  84.   (view-diary-entries arg))
  85.  
  86. (autoload 'check-calendar-holidays "holidays"
  87.   "Check the list of holidays for any that occur on DATE.
  88. The value returned is a list of strings of relevant holiday descriptions.
  89. The holidays are those in the list `calendar-holidays'."
  90.   t)
  91.  
  92. (autoload 'calendar-holiday-list "holidays"
  93.   "Form the list of holidays that occur on dates in the calendar window.
  94. The holidays are those in the list `calendar-holidays'."
  95.   t)
  96.  
  97. (autoload 'diary-french-date "cal-french"
  98.   "French calendar equivalent of date diary entry."
  99.   t)
  100.  
  101. (autoload 'diary-mayan-date "cal-mayan"
  102.   "Mayan calendar equivalent of date diary entry."
  103.   t)
  104.  
  105. (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
  106.  
  107. (autoload 'diary-sunrise-sunset "solar"
  108.   "Local time of sunrise and sunset as a diary entry."
  109.   t)
  110.  
  111. (autoload 'diary-sabbath-candles "solar"
  112.   "Local time of candle lighting diary entry--applies if date is a Friday.
  113. No diary entry if there is no sunset on that date."
  114.   t)
  115.  
  116. (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
  117.   "The syntax table used when parsing dates in the diary file.
  118. It is the standard syntax table used in Fundamental mode, but with the
  119. syntax of `*' changed to be a word constituent.")
  120.  
  121. (modify-syntax-entry ?* "w" diary-syntax-table)
  122.  
  123. (defun list-diary-entries (date number)
  124.   "Create and display a buffer containing the relevant lines in diary-file.
  125. The arguments are DATE and NUMBER; the entries selected are those
  126. for NUMBER days starting with date DATE.  The other entries are hidden
  127. using selective display.
  128.  
  129. Returns a list of all relevant diary entries found, if any, in order by date.
  130. The list entries have the form ((month day year) string).  If the variable
  131. `diary-list-include-blanks' is t, this list includes a dummy diary entry
  132. \(consisting of the empty string) for a date with no diary entries.
  133.  
  134. After the list is prepared, the hooks `nongregorian-diary-listing-hook',
  135. `list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
  136. These hooks have the following distinct roles:
  137.  
  138.     `nongregorian-diary-listing-hook' can cull dates from the diary
  139.         and each included file.  Usually used for Hebrew or Islamic
  140.         diary entries in files.  Applied to *each* file.
  141.  
  142.     `list-diary-entries-hook' adds or manipulates diary entries from
  143.         external sources.  Used, for example, to include diary entries
  144.         from other files or to sort the diary entries.  Invoked *once* only,
  145.         before the display hook is run.
  146.  
  147.     `diary-display-hook' does the actual display of information.  If this is
  148.         nil, simple-diary-display will be used.  Use add-hook to set this to
  149.         fancy-diary-display, if desired.  If you want no diary display, use
  150.         add-hook to set this to ignore.
  151.  
  152.     `diary-hook' is run last.  This can be used for an appointment
  153.         notification function."
  154.  
  155.   (if (< 0 number)
  156.       (let* ((original-date date);; save for possible use in the hooks
  157.              (old-diary-syntax-table)
  158.              (diary-entries-list)
  159.              (date-string (calendar-date-string date))
  160.              (d-file (substitute-in-file-name diary-file)))
  161.         (message "Preparing diary...")
  162.         (save-excursion
  163.           (let ((diary-buffer (get-file-buffer d-file)))
  164.             (set-buffer (if diary-buffer
  165.                             diary-buffer
  166.                          (find-file-noselect d-file t))))
  167.           (setq selective-display t)
  168.           (setq selective-display-ellipses nil)
  169.           (setq old-diary-syntax-table (syntax-table))
  170.           (set-syntax-table diary-syntax-table)
  171.           (unwind-protect
  172.             (let ((buffer-read-only nil)
  173.                   (diary-modified (buffer-modified-p))
  174.                   (mark (regexp-quote diary-nonmarking-symbol)))
  175.               (goto-char (1- (point-max)))
  176.               (if (not (looking-at "\^M\\|\n"))
  177.                   (progn
  178.                     (forward-char 1)
  179.                     (insert-string "\^M")))
  180.               (goto-char (point-min))
  181.               (if (not (looking-at "\^M\\|\n"))
  182.                   (insert-string "\^M"))
  183.               (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
  184.               (calendar-for-loop i from 1 to number do
  185.                  (let ((d diary-date-forms)
  186.                        (month (extract-calendar-month date))
  187.                        (day (extract-calendar-day date))
  188.                        (year (extract-calendar-year date))
  189.                        (entry-found (list-sexp-diary-entries date)))
  190.                    (while d
  191.                      (let*
  192.                           ((date-form (if (equal (car (car d)) 'backup)
  193.                                           (cdr (car d))
  194.                                         (car d)))
  195.                           (backup (equal (car (car d)) 'backup))
  196.                           (dayname
  197.                            (concat
  198.                             (calendar-day-name date) "\\|"
  199.                             (substring (calendar-day-name date) 0 3) ".?"))
  200.                           (monthname
  201.                            (concat
  202.                             "\\*\\|"
  203.                             (calendar-month-name month) "\\|"
  204.                             (substring (calendar-month-name month) 0 3) ".?"))
  205.                           (month (concat "\\*\\|0*" (int-to-string month)))
  206.                           (day (concat "\\*\\|0*" (int-to-string day)))
  207.                           (year
  208.                            (concat
  209.                             "\\*\\|0*" (int-to-string year)
  210.                             (if abbreviated-calendar-year
  211.                                 (concat "\\|" (int-to-string (% year 100)))
  212.                               "")))
  213.                           (regexp
  214.                            (concat
  215.                             "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
  216.                             (mapconcat 'eval date-form "\\)\\(")
  217.                             "\\)"))
  218.                           (case-fold-search t))
  219.                        (goto-char (point-min))
  220.                        (while (re-search-forward regexp nil t)
  221.                          (if backup (re-search-backward "\\<" nil t))
  222.                          (if (and (or (char-equal (preceding-char) ?\^M)
  223.                                       (char-equal (preceding-char) ?\n))
  224.                                   (not (looking-at " \\|\^I")))
  225.                              ;;  Diary entry that consists only of date.
  226.                              (backward-char 1)
  227.                            ;; Found a nonempty diary entry--make it visible and
  228.                            ;; add it to the list.
  229.                            (setq entry-found t)
  230.                            (let ((entry-start (point))
  231.                                  (date-start))
  232.                              (re-search-backward "\^M\\|\n\\|\\`")
  233.                              (setq date-start (point))
  234.                              (re-search-forward "\^M\\|\n" nil t 2)
  235.                              (while (looking-at " \\|\^I")
  236.                                (re-search-forward "\^M\\|\n" nil t))
  237.                              (backward-char 1)
  238.                              (subst-char-in-region date-start
  239.                                 (point) ?\^M ?\n t)
  240.                              (add-to-diary-list
  241.                                date (buffer-substring entry-start (point)))))))
  242.                      (setq d (cdr d)))
  243.                    (or entry-found
  244.                        (not diary-list-include-blanks)
  245.                        (setq diary-entries-list 
  246.                              (append diary-entries-list
  247.                                      (list (list date "")))))
  248.                    (setq date
  249.                          (calendar-gregorian-from-absolute
  250.                            (1+ (calendar-absolute-from-gregorian date))))
  251.                    (setq entry-found nil)))
  252.               (set-buffer-modified-p diary-modified))
  253.           (set-syntax-table old-diary-syntax-table))
  254.         (goto-char (point-min))
  255.         (run-hooks 'nongregorian-diary-listing-hook
  256.                    'list-diary-entries-hook)
  257.         (if diary-display-hook
  258.             (run-hooks 'diary-display-hook)
  259.           (simple-diary-display))
  260.         (run-hooks 'diary-hook)
  261.         diary-entries-list))))
  262.  
  263. (defun include-other-diary-files ()
  264.   "Include the diary entries from other diary files with those of diary-file.
  265. This function is suitable for use in `list-diary-entries-hook';
  266. it enables you to use shared diary files together with your own.
  267. The files included are specified in the diaryfile by lines of this form:
  268.         #include \"filename\"
  269. This is recursive; that is, #include directives in diary files thus included
  270. are obeyed.  You can change the `#include' to some other string by
  271. changing the variable `diary-include-string'."
  272.   (goto-char (point-min))
  273.   (while (re-search-forward
  274.           (concat
  275.            "\\(\\`\\|\^M\\|\n\\)"
  276.            (regexp-quote diary-include-string)
  277.            " \"\\([^\"]*\\)\"")
  278.           nil t)
  279.     (let ((diary-file (substitute-in-file-name
  280.                        (buffer-substring (match-beginning 2) (match-end 2))))
  281.           (diary-list-include-blanks nil)
  282.           (list-diary-entries-hook 'include-other-diary-files)
  283.           (diary-display-hook 'ignore)
  284.           (diary-hook nil))
  285.       (if (file-exists-p diary-file)
  286.           (if (file-readable-p diary-file)
  287.               (unwind-protect
  288.                   (setq diary-entries-list
  289.                         (append diary-entries-list
  290.                                 (list-diary-entries original-date number)))
  291.                 (kill-buffer (get-file-buffer diary-file)))
  292.             (beep)
  293.             (message "Can't read included diary file %s" diary-file)
  294.             (sleep-for 2))
  295.         (beep)
  296.         (message "Can't find included diary file %s" diary-file)
  297.         (sleep-for 2))))
  298.     (goto-char (point-min)))
  299.  
  300. (defun simple-diary-display ()
  301.   "Display the diary buffer if there are any relevant entries or holidays."
  302.   (let* ((holiday-list (if holidays-in-diary-buffer
  303.                            (check-calendar-holidays original-date)))
  304.          (msg (format "No diary entries for %s %s"
  305.                       (concat date-string (if holiday-list ":" ""))
  306.                       (mapconcat 'identity holiday-list "; "))))
  307.     (if (or (not diary-entries-list)
  308.             (and (not (cdr diary-entries-list))
  309.                  (string-equal (car (cdr (car diary-entries-list))) "")))
  310.         (if (<= (length msg) (frame-width))
  311.             (message msg)
  312.           (set-buffer (get-buffer-create holiday-buffer))
  313.           (setq buffer-read-only nil)
  314.           (calendar-set-mode-line date-string)
  315.           (erase-buffer)
  316.           (insert (mapconcat 'identity holiday-list "\n"))
  317.           (goto-char (point-min))
  318.           (set-buffer-modified-p nil)
  319.           (setq buffer-read-only t)
  320.           (display-buffer holiday-buffer)
  321.           (message  "No diary entries for %s" date-string))
  322.       (calendar-set-mode-line
  323.        (concat "Diary for " date-string
  324.                (if holiday-list ": " "")
  325.                (mapconcat 'identity holiday-list "; ")))
  326.       (display-buffer (get-file-buffer d-file))
  327.       (message "Preparing diary...done"))))
  328.  
  329. (defun fancy-diary-display ()
  330.   "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
  331. This function is provided for optional use as the `diary-display-hook'."
  332.   (save-excursion;; Turn off selective-display in the diary file's buffer.
  333.     (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
  334.     (let ((diary-modified (buffer-modified-p)))
  335.       (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  336.       (setq selective-display nil)
  337.       (kill-local-variable 'mode-line-format)
  338.       (set-buffer-modified-p diary-modified)))
  339.   (if (or (not diary-entries-list)
  340.           (and (not (cdr diary-entries-list))
  341.                (string-equal (car (cdr (car diary-entries-list))) "")))
  342.       (let* ((holiday-list (if holidays-in-diary-buffer
  343.                                (check-calendar-holidays original-date)))
  344.              (msg (format "No diary entries for %s %s"
  345.                           (concat date-string (if holiday-list ":" ""))
  346.                           (mapconcat 'identity holiday-list "; "))))
  347.         (if (<= (length msg) (frame-width))
  348.             (message msg)
  349.           (set-buffer (get-buffer-create holiday-buffer))
  350.           (setq buffer-read-only nil)
  351.           (calendar-set-mode-line date-string)
  352.           (erase-buffer)
  353.           (insert (mapconcat 'identity holiday-list "\n"))
  354.           (goto-char (point-min))
  355.           (set-buffer-modified-p nil)
  356.           (setq buffer-read-only t)
  357.           (display-buffer holiday-buffer)
  358.           (message  "No diary entries for %s" date-string)))
  359.     (save-excursion;; Prepare the fancy diary buffer.
  360.       (set-buffer (get-buffer-create fancy-diary-buffer))
  361.       (setq buffer-read-only nil)
  362.       (setq modeline-buffer-identification '("Diary Entries"))
  363.       (erase-buffer)
  364.       (let ((entry-list diary-entries-list)
  365.             (holiday-list)
  366.             (holiday-list-last-month 1)
  367.             (holiday-list-last-year 1)
  368.             (date (list 0 0 0)))
  369.         (while entry-list
  370.           (if (not (calendar-date-equal date (car (car entry-list))))
  371.               (progn
  372.                 (setq date (car (car entry-list)))
  373.                 (and holidays-in-diary-buffer
  374.                      (calendar-date-compare
  375.                       (list (list holiday-list-last-month
  376.                                   (calendar-last-day-of-month
  377.                                    holiday-list-last-month
  378.                                    holiday-list-last-year)
  379.                                   holiday-list-last-year))
  380.                       (list date))
  381.                      ;; We need to get the holidays for the next 3 months.
  382.                      (setq holiday-list-last-month
  383.                            (extract-calendar-month date))
  384.                      (setq holiday-list-last-year
  385.                            (extract-calendar-year date))
  386.                      (increment-calendar-month
  387.                       holiday-list-last-month holiday-list-last-year 1)
  388.                      (setq holiday-list
  389.                            (let ((displayed-month holiday-list-last-month)
  390.                                  (displayed-year holiday-list-last-year))
  391.                              (calendar-holiday-list)))
  392.                      (increment-calendar-month
  393.                       holiday-list-last-month holiday-list-last-year 1))
  394.                 (let* ((date-string (calendar-date-string date))
  395.                        (date-holiday-list
  396.                         (let ((h holiday-list)
  397.                               (d))
  398.                           ;; Make a list of all holidays for date.
  399.                           (while h
  400.                             (if (calendar-date-equal date (car (car h)))
  401.                                 (setq d (append d (cdr (car h)))))
  402.                             (setq h (cdr h)))
  403.                           d)))
  404.                   (insert (if (= (point) (point-min)) "" ?\n) date-string)
  405.                   (if date-holiday-list (insert ":  "))
  406.                   (let ((l (current-column)))
  407.                     (insert (mapconcat 'identity date-holiday-list
  408.                                        (concat "\n" (make-string l ? )))))
  409.                   (let ((l (current-column)))
  410.                     (insert ?\n (make-string l ?=) ?\n)))))
  411.           (if (< 0 (length (car (cdr (car entry-list)))))
  412.               (insert (car (cdr (car entry-list))) ?\n))
  413.           (setq entry-list (cdr entry-list))))
  414.       (set-buffer-modified-p nil)
  415.       (goto-char (point-min))
  416.       (setq buffer-read-only t)
  417.       (display-buffer fancy-diary-buffer)
  418.       (message "Preparing diary...done"))))
  419.  
  420. (defun print-diary-entries ()
  421.   "Print a hard copy of the diary display.
  422.  
  423. If the simple diary display is being used, prepare a temp buffer with the
  424. visible lines of the diary buffer, add a heading line composed from the mode
  425. line, print the temp buffer, and destroy it.
  426.  
  427. If the fancy diary display is being used, just print the buffer.
  428.  
  429. The hooks given by the variable `print-diary-entries-hook' are called to do
  430. the actual printing."
  431.   (interactive)
  432.   (if (bufferp (get-buffer fancy-diary-buffer))
  433.       (save-excursion
  434.         (set-buffer (get-buffer fancy-diary-buffer))
  435.         (run-hooks 'print-diary-entries-hook))
  436.     (let ((diary-buffer
  437.            (get-file-buffer (substitute-in-file-name diary-file))))
  438.       (if diary-buffer
  439.           (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
  440.                 (heading))
  441.             (save-excursion
  442.               (set-buffer diary-buffer)
  443.               (setq heading
  444.                     (if (not (stringp mode-line-format))
  445.                         "All Diary Entries"
  446.                       (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
  447.                       (substring mode-line-format
  448.                                  (match-beginning 1) (match-end 1))))
  449.               (copy-to-buffer temp-buffer (point-min) (point-max))
  450.               (set-buffer temp-buffer)
  451.               (while (re-search-forward "\^M.*$" nil t)
  452.                 (replace-match ""))
  453.               (goto-char (point-min))
  454.               (insert heading "\n"
  455.                       (make-string (length heading) ?=) "\n")
  456.               (run-hooks 'print-diary-entries-hook)
  457.               (kill-buffer temp-buffer)))
  458.         (error "You don't have a diary buffer!")))))
  459.  
  460. (defun show-all-diary-entries ()
  461.   "Show all of the diary entries in the diary file.
  462. This function gets rid of the selective display of the diary file so that
  463. all entries, not just some, are visible.  If there is no diary buffer, one
  464. is created."
  465.   (interactive)
  466.   (let ((d-file (substitute-in-file-name diary-file)))
  467.     (if (and d-file (file-exists-p d-file))
  468.         (if (file-readable-p d-file)
  469.             (save-excursion
  470.               (let ((diary-buffer (get-file-buffer d-file)))
  471.                 (set-buffer (if diary-buffer
  472.                                 diary-buffer
  473.                               (find-file-noselect d-file t)))
  474.                 (let ((buffer-read-only nil)
  475.                       (diary-modified (buffer-modified-p)))
  476.                   (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  477.                   (setq selective-display nil)
  478.                   (make-local-variable 'mode-line-format)
  479.                   (setq mode-line-format default-mode-line-format)
  480.                   (display-buffer (current-buffer))
  481.                   (set-buffer-modified-p diary-modified))))
  482.           (error "Your diary file is not readable!"))
  483.       (error "You don't have a diary file!"))))
  484.  
  485. (defun diary-name-pattern (string-array &optional fullname)
  486.   "Convert an STRING-ARRAY, an array of strings to a pattern.
  487. The pattern will match any of the strings, either entirely or abbreviated
  488. to three characters.  An abbreviated form will match with or without a period;
  489. If the optional FULLNAME is t, abbreviations will not match, just the full
  490. name."
  491.   (let ((pattern ""))
  492.     (calendar-for-loop i from 0 to (1- (length string-array)) do
  493.       (setq pattern
  494.             (concat
  495.              pattern
  496.              (if (string-equal pattern "") "" "\\|")
  497.              (aref string-array i)
  498.              (if fullname
  499.                  ""
  500.                (concat
  501.                 "\\|"
  502.                 (substring (aref string-array i) 0 3) ".?")))))
  503.     pattern))
  504.  
  505. (defun mark-diary-entries ()
  506.   "Mark days in the calendar window that have diary entries.
  507. Each entry in the diary file visible in the calendar window is marked.
  508. After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
  509. `mark-diary-entries-hook' are run."
  510.   (interactive)
  511.   (setq mark-diary-entries-in-calendar t)
  512.   (let ((d-file (substitute-in-file-name diary-file)))
  513.     (if (and d-file (file-exists-p d-file))
  514.         (if (file-readable-p d-file)
  515.             (save-excursion
  516.               (message "Marking diary entries...")
  517.               (set-buffer (find-file-noselect d-file t))
  518.               (let ((d diary-date-forms)
  519.                     (old-diary-syntax-table))
  520.                 (setq old-diary-syntax-table (syntax-table))
  521.                 (set-syntax-table diary-syntax-table)
  522.                 (while d
  523.                   (let*
  524.                       ((date-form (if (equal (car (car d)) 'backup)
  525.                                       (cdr (car d))
  526.                                     (car d)));; ignore 'backup directive
  527.                        (dayname (diary-name-pattern calendar-day-name-array))
  528.                        (monthname
  529.                         (concat
  530.                          (diary-name-pattern calendar-month-name-array)
  531.                          "\\|\\*"))
  532.                        (month "[0-9]+\\|\\*")
  533.                        (day "[0-9]+\\|\\*")
  534.                        (year "[0-9]+\\|\\*")
  535.                        (l (length date-form))
  536.                        (d-name-pos (- l (length (memq 'dayname date-form))))
  537.                        (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  538.                        (m-name-pos (- l (length (memq 'monthname date-form))))
  539.                        (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  540.                        (d-pos (- l (length (memq 'day date-form))))
  541.                        (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  542.                        (m-pos (- l (length (memq 'month date-form))))
  543.                        (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  544.                        (y-pos (- l (length (memq 'year date-form))))
  545.                        (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  546.                        (regexp
  547.                         (concat
  548.                          "\\(\\`\\|\^M\\|\n\\)\\("
  549.                          (mapconcat 'eval date-form "\\)\\(")
  550.                          "\\)"))
  551.                        (case-fold-search t))
  552.                     (goto-char (point-min))
  553.                     (while (re-search-forward regexp nil t)
  554.                       (let* ((dd-name
  555.                               (if d-name-pos
  556.                                   (buffer-substring
  557.                                    (match-beginning d-name-pos)
  558.                                    (match-end d-name-pos))))
  559.                              (mm-name
  560.                               (if m-name-pos
  561.                                   (buffer-substring
  562.                                    (match-beginning m-name-pos)
  563.                                    (match-end m-name-pos))))
  564.                              (mm (string-to-int
  565.                                   (if m-pos
  566.                                       (buffer-substring
  567.                                        (match-beginning m-pos)
  568.                                        (match-end m-pos))
  569.                                     "")))
  570.                              (dd (string-to-int
  571.                                   (if d-pos
  572.                                       (buffer-substring
  573.                                        (match-beginning d-pos)
  574.                                        (match-end d-pos))
  575.                                     "")))
  576.                              (y-str (if y-pos
  577.                                         (buffer-substring
  578.                                          (match-beginning y-pos)
  579.                                          (match-end y-pos))))
  580.                              (yy (if (not y-str)
  581.                                      0
  582.                                    (if (and (= (length y-str) 2)
  583.                                             abbreviated-calendar-year)
  584.                                        (let* ((current-y
  585.                                                (extract-calendar-year
  586.                                                 (calendar-current-date)))
  587.                                               (y (+ (string-to-int y-str)
  588.                                                     (* 100
  589.                                                        (/ current-y 100)))))
  590.                                          (if (> (- y current-y) 50)
  591.                                              (- y 100)
  592.                                            (if (> (- current-y y) 50)
  593.                                                (+ y 100)
  594.                                              y)))
  595.                                      (string-to-int y-str)))))
  596.                         (if dd-name
  597.                             (mark-calendar-days-named
  598.                              (cdr (assoc (capitalize (substring dd-name 0 3))
  599.                                          (calendar-make-alist
  600.                                           calendar-day-name-array
  601.                                           0
  602.                                           '(lambda (x) (substring x 0 3))))))
  603.                           (if mm-name
  604.                               (if (string-equal mm-name "*")
  605.                                   (setq mm 0)
  606.                                 (setq mm
  607.                                       (cdr (assoc
  608.                                             (capitalize
  609.                                              (substring mm-name 0 3))
  610.                                             (calendar-make-alist
  611.                                              calendar-month-name-array
  612.                                              1
  613.                                              '(lambda (x) (substring x 0 3)))
  614.                                             )))))
  615.                           (mark-calendar-date-pattern mm dd yy))))
  616.                     (setq d (cdr d))))
  617.                 (mark-sexp-diary-entries)
  618.                 (run-hooks 'nongregorian-diary-marking-hook
  619.                            'mark-diary-entries-hook)
  620.                 (set-syntax-table old-diary-syntax-table)
  621.                 (message "Marking diary entries...done")))
  622.           (error "Your diary file is not readable!"))
  623.       (error "You don't have a diary file!"))))
  624.  
  625. (defun mark-sexp-diary-entries ()
  626.   "Mark days in the calendar window that have sexp diary entries.
  627. Each entry in the diary file (or included files) visible in the calendar window
  628. is marked.  See the documentation for the function `list-sexp-diary-entries'."
  629.   (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
  630.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
  631.          (m)
  632.          (y)
  633.          (first-date)
  634.          (last-date))
  635.     (save-excursion
  636.       (set-buffer calendar-buffer)
  637.       (setq m displayed-month)
  638.       (setq y displayed-year))
  639.     (increment-calendar-month m y -1)
  640.     (setq first-date
  641.           (calendar-absolute-from-gregorian (list m 1 y)))
  642.     (increment-calendar-month m y 2)
  643.     (setq last-date
  644.           (calendar-absolute-from-gregorian
  645.            (list m (calendar-last-day-of-month m y) y)))
  646.     (goto-char (point-min))
  647.     (while (re-search-forward s-entry nil t)
  648.       (backward-char 1)
  649.       (let ((sexp-start (point))
  650.             (sexp)
  651.             (entry)
  652.             (entry-start)
  653.             (line-start))
  654.         (forward-sexp)
  655.         (setq sexp (buffer-substring sexp-start (point)))
  656.         (save-excursion
  657.           (re-search-backward "\^M\\|\n\\|\\`")
  658.           (setq line-start (point)))
  659.         (forward-char 1)
  660.         (if (and (or (char-equal (preceding-char) ?\^M)
  661.                      (char-equal (preceding-char) ?\n))
  662.                  (not (looking-at " \\|\^I")))
  663.             (progn;; Diary entry consists only of the sexp
  664.               (backward-char 1)
  665.               (setq entry ""))
  666.           (setq entry-start (point))
  667.           (re-search-forward "\^M\\|\n" nil t)
  668.           (while (looking-at " \\|\^I")
  669.             (re-search-forward "\^M\\|\n" nil t))
  670.           (backward-char 1)
  671.           (setq entry (buffer-substring entry-start (point)))
  672.           (while (string-match "[\^M]" entry)
  673.             (aset entry (match-beginning 0) ?\n )))
  674.         (calendar-for-loop date from first-date to last-date do
  675.           (if (diary-sexp-entry sexp entry
  676.                                 (calendar-gregorian-from-absolute date))
  677.               (mark-visible-calendar-date
  678.                (calendar-gregorian-from-absolute date))))))))
  679.  
  680. (defun mark-included-diary-files ()
  681.   "Mark the diary entries from other diary files with those of the diary file.
  682. This function is suitable for use as the `mark-diary-entries-hook'; it enables
  683. you to use shared diary files together with your own.  The files included are
  684. specified in the diary-file by lines of this form:
  685.         #include \"filename\"
  686. This is recursive; that is, #include directives in diary files thus included
  687. are obeyed.  You can change the `#include' to some other string by
  688. changing the variable `diary-include-string'."
  689.   (goto-char (point-min))
  690.   (while (re-search-forward
  691.           (concat
  692.            "\\(\\`\\|\^M\\|\n\\)"
  693.            (regexp-quote diary-include-string)
  694.            " \"\\([^\"]*\\)\"")
  695.           nil t)
  696.     (let ((diary-file (substitute-in-file-name
  697.                        (buffer-substring (match-beginning 2) (match-end 2))))
  698.           (mark-diary-entries-hook 'mark-included-diary-files))
  699.       (if (file-exists-p diary-file)
  700.           (if (file-readable-p diary-file)
  701.               (progn
  702.                 (mark-diary-entries)
  703.                 (kill-buffer (get-file-buffer diary-file)))
  704.             (beep)
  705.             (message "Can't read included diary file %s" diary-file)
  706.             (sleep-for 2))
  707.         (beep)
  708.         (message "Can't find included diary file %s" diary-file)
  709.         (sleep-for 2))))
  710.   (goto-char (point-min)))
  711.  
  712. (defun mark-calendar-days-named (dayname)
  713.   "Mark all dates in the calendar window that are day DAYNAME of the week.
  714. 0 means all Sundays, 1 means all Mondays, and so on."
  715.   (save-excursion
  716.     (set-buffer calendar-buffer)
  717.     (let ((prev-month displayed-month)
  718.           (prev-year displayed-year)
  719.           (succ-month displayed-month)
  720.           (succ-year displayed-year)
  721.           (last-day)
  722.           (day))
  723.       (increment-calendar-month succ-month succ-year 1)
  724.       (increment-calendar-month prev-month prev-year -1)
  725.       (setq day (calendar-absolute-from-gregorian
  726.                  (calendar-nth-named-day 1 dayname prev-month prev-year)))
  727.       (setq last-day (calendar-absolute-from-gregorian
  728.                  (calendar-nth-named-day -1 dayname succ-month succ-year)))
  729.       (while (<= day last-day)
  730.         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
  731.         (setq day (+ day 7))))))
  732.  
  733. (defun mark-calendar-date-pattern (month day year)
  734.   "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  735. A value of 0 in any position is a wildcard."
  736.   (save-excursion
  737.     (set-buffer calendar-buffer)
  738.     (let ((m displayed-month)
  739.           (y displayed-year))
  740.       (increment-calendar-month m y -1)
  741.       (calendar-for-loop i from 0 to 2 do
  742.           (mark-calendar-month m y month day year)
  743.           (increment-calendar-month m y 1)))))
  744.  
  745. (defun mark-calendar-month (month year p-month p-day p-year)
  746.   "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  747. A value of 0 in any position of the pattern is a wildcard."
  748.   (if (or (and (= month p-month)
  749.                (or (= p-year 0) (= year p-year)))
  750.           (and (= p-month 0)
  751.                (or (= p-year 0) (= year p-year))))
  752.       (if (= p-day 0)
  753.           (calendar-for-loop
  754.               i from 1 to (calendar-last-day-of-month month year) do
  755.             (mark-visible-calendar-date (list month i year)))
  756.         (mark-visible-calendar-date (list month p-day year)))))
  757.  
  758. (defun sort-diary-entries ()
  759.   "Sort the list of diary entries by time of day."
  760.   (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
  761.  
  762. (defun diary-entry-compare (e1 e2)
  763.   "Returns t if E1 is earlier than E2."
  764.   (or (calendar-date-compare e1 e2)
  765.       (and (calendar-date-equal (car e1) (car e2))
  766.            (< (diary-entry-time (car (cdr e1)))
  767.               (diary-entry-time (car (cdr e2)))))))
  768.  
  769. (defun diary-entry-time (s)
  770.   "Time at the beginning of the string S in a military-style integer.
  771. For example, returns 1325 for 1:25pm.  Returns -9999 if no time is recognized.
  772. The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
  773. and XX:XXam or XX:XXpm."
  774.   (cond ((string-match;; Military time  
  775.           "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
  776.          (+ (* 100 (string-to-int
  777.                     (substring s (match-beginning 1) (match-end 1))))
  778.             (string-to-int (substring s (match-beginning 2) (match-end 2)))))
  779.         ((string-match;; Hour only  XXam or XXpm
  780.           "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
  781.          (+ (* 100 (% (string-to-int
  782.                          (substring s (match-beginning 1) (match-end 1)))
  783.                         12))
  784.             (if (string-equal "a"
  785.                               (substring s (match-beginning 2) (match-end 2)))
  786.                 0 1200)))
  787.         ((string-match;; Hour and minute  XX:XXam or XX:XXpm
  788.           "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
  789.          (+ (* 100 (% (string-to-int
  790.                          (substring s (match-beginning 1) (match-end 1)))
  791.                         12))
  792.             (string-to-int (substring s (match-beginning 2) (match-end 2)))
  793.             (if (string-equal "a"
  794.                               (substring s (match-beginning 3) (match-end 3)))
  795.                 0 1200)))
  796.         (t -9999)));; Unrecognizable
  797.  
  798. (defun list-hebrew-diary-entries ()
  799.   "Add any Hebrew date entries from the diary file to `diary-entries-list'.
  800. Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
  801. \(normally an `H').  The same diary date forms govern the style of the Hebrew
  802. calendar entries, except that the Hebrew month names must be spelled in full.
  803. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  804. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  805. common Hebrew year.  If a Hebrew date diary entry begins with a
  806. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  807. not be marked in the calendar.  This function is provided for use with the
  808. `nongregorian-diary-listing-hook'."
  809.   (if (< 0 number)
  810.       (let ((buffer-read-only nil)
  811.             (diary-modified (buffer-modified-p))
  812.             (gdate original-date)
  813.             (mark (regexp-quote diary-nonmarking-symbol)))
  814.         (calendar-for-loop i from 1 to number do
  815.            (let* ((d diary-date-forms)
  816.                   (hdate (calendar-hebrew-from-absolute 
  817.                           (calendar-absolute-from-gregorian gdate)))
  818.                   (month (extract-calendar-month hdate))
  819.                   (day (extract-calendar-day hdate))
  820.                   (year (extract-calendar-year hdate)))
  821.              (while d
  822.                (let*
  823.                    ((date-form (if (equal (car (car d)) 'backup)
  824.                                    (cdr (car d))
  825.                                  (car d)))
  826.                     (backup (equal (car (car d)) 'backup))
  827.                     (dayname
  828.                      (concat
  829.                       (calendar-day-name gdate) "\\|"
  830.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  831.                     (calendar-month-name-array
  832.                      calendar-hebrew-month-name-array-leap-year)
  833.                     (monthname
  834.                      (concat
  835.                       "\\*\\|"
  836.                       (calendar-month-name month)))
  837.                     (month (concat "\\*\\|0*" (int-to-string month)))
  838.                     (day (concat "\\*\\|0*" (int-to-string day)))
  839.                     (year
  840.                      (concat
  841.                       "\\*\\|0*" (int-to-string year)
  842.                       (if abbreviated-calendar-year
  843.                           (concat "\\|" (int-to-string (% year 100)))
  844.                         "")))
  845.                     (regexp
  846.                      (concat
  847.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  848.                       (regexp-quote hebrew-diary-entry-symbol)
  849.                       "\\("
  850.                       (mapconcat 'eval date-form "\\)\\(")
  851.                       "\\)"))
  852.                     (case-fold-search t))
  853.                  (goto-char (point-min))
  854.                  (while (re-search-forward regexp nil t)
  855.                    (if backup (re-search-backward "\\<" nil t))
  856.                    (if (and (or (char-equal (preceding-char) ?\^M)
  857.                                 (char-equal (preceding-char) ?\n))
  858.                             (not (looking-at " \\|\^I")))
  859.                        ;;  Diary entry that consists only of date.
  860.                        (backward-char 1)
  861.                      ;;  Found a nonempty diary entry--make it visible and
  862.                      ;;  add it to the list.
  863.                      (let ((entry-start (point))
  864.                            (date-start))
  865.                        (re-search-backward "\^M\\|\n\\|\\`")
  866.                        (setq date-start (point))
  867.                        (re-search-forward "\^M\\|\n" nil t 2)
  868.                        (while (looking-at " \\|\^I")
  869.                          (re-search-forward "\^M\\|\n" nil t))
  870.                        (backward-char 1)
  871.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  872.                        (add-to-diary-list
  873.                          gdate (buffer-substring entry-start (point)))))))
  874.                (setq d (cdr d))))
  875.            (setq gdate
  876.                  (calendar-gregorian-from-absolute
  877.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  878.            (set-buffer-modified-p diary-modified))
  879.         (goto-char (point-min))))
  880.  
  881. (defun mark-hebrew-diary-entries ()
  882.   "Mark days in the calendar window that have Hebrew date diary entries.
  883. Each entry in diary-file (or included files) visible in the calendar window
  884. is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
  885. \(normally an `H').  The same diary-date-forms govern the style of the Hebrew
  886. calendar entries, except that the Hebrew month names must be spelled in full.
  887. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  888. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  889. common Hebrew year.  Hebrew date diary entries that begin with a
  890. diary-nonmarking symbol will not be marked in the calendar.  This function
  891. is provided for use as part of the nongregorian-diary-marking-hook."
  892.   (let ((d diary-date-forms))
  893.     (while d
  894.       (let*
  895.           ((date-form (if (equal (car (car d)) 'backup)
  896.                           (cdr (car d))
  897.                         (car d)));; ignore 'backup directive
  898.            (dayname (diary-name-pattern calendar-day-name-array))
  899.            (monthname
  900.             (concat
  901.              (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
  902.              "\\|\\*"))
  903.            (month "[0-9]+\\|\\*")
  904.            (day "[0-9]+\\|\\*")
  905.            (year "[0-9]+\\|\\*")
  906.            (l (length date-form))
  907.            (d-name-pos (- l (length (memq 'dayname date-form))))
  908.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  909.            (m-name-pos (- l (length (memq 'monthname date-form))))
  910.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  911.            (d-pos (- l (length (memq 'day date-form))))
  912.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  913.            (m-pos (- l (length (memq 'month date-form))))
  914.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  915.            (y-pos (- l (length (memq 'year date-form))))
  916.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  917.            (regexp
  918.             (concat
  919.              "\\(\\`\\|\^M\\|\n\\)"
  920.              (regexp-quote hebrew-diary-entry-symbol)
  921.              "\\("
  922.              (mapconcat 'eval date-form "\\)\\(")
  923.              "\\)"))
  924.            (case-fold-search t))
  925.         (goto-char (point-min))
  926.         (while (re-search-forward regexp nil t)
  927.           (let* ((dd-name
  928.                   (if d-name-pos
  929.                       (buffer-substring
  930.                        (match-beginning d-name-pos)
  931.                        (match-end d-name-pos))))
  932.                  (mm-name
  933.                   (if m-name-pos
  934.                       (buffer-substring
  935.                        (match-beginning m-name-pos)
  936.                        (match-end m-name-pos))))
  937.                  (mm (string-to-int
  938.                       (if m-pos
  939.                           (buffer-substring
  940.                            (match-beginning m-pos)
  941.                            (match-end m-pos))
  942.                         "")))
  943.                  (dd (string-to-int
  944.                       (if d-pos
  945.                           (buffer-substring
  946.                            (match-beginning d-pos)
  947.                            (match-end d-pos))
  948.                         "")))
  949.                  (y-str (if y-pos
  950.                             (buffer-substring
  951.                              (match-beginning y-pos)
  952.                              (match-end y-pos))))
  953.                  (yy (if (not y-str)
  954.                          0
  955.                        (if (and (= (length y-str) 2)
  956.                                 abbreviated-calendar-year)
  957.                            (let* ((current-y
  958.                                    (extract-calendar-year
  959.                                     (calendar-hebrew-from-absolute
  960.                                      (calendar-absolute-from-gregorian
  961.                                       (calendar-current-date)))))
  962.                                   (y (+ (string-to-int y-str)
  963.                                         (* 100 (/ current-y 100)))))
  964.                              (if (> (- y current-y) 50)
  965.                                  (- y 100)
  966.                                (if (> (- current-y y) 50)
  967.                                    (+ y 100)
  968.                                  y)))
  969.                          (string-to-int y-str)))))
  970.             (if dd-name
  971.                 (mark-calendar-days-named
  972.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  973.                              (calendar-make-alist
  974.                                calendar-day-name-array
  975.                                0
  976.                               '(lambda (x) (substring x 0 3))))))
  977.               (if mm-name
  978.                   (if (string-equal mm-name "*")
  979.                       (setq mm 0)
  980.                     (setq
  981.                       mm
  982.                       (cdr 
  983.                         (assoc
  984.                           (capitalize mm-name)
  985.                             (calendar-make-alist
  986.                                calendar-hebrew-month-name-array-leap-year))))))
  987.               (mark-hebrew-calendar-date-pattern mm dd yy)))))
  988.       (setq d (cdr d)))))
  989.  
  990. (defun mark-hebrew-calendar-date-pattern (month day year)
  991.   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
  992. A value of 0 in any position is a wildcard."
  993.   (save-excursion
  994.     (set-buffer calendar-buffer)
  995.     (if (and (/= 0 month) (/= 0 day))
  996.         (if (/= 0 year)
  997.             ;; Fully specified Hebrew date.
  998.             (let ((date (calendar-gregorian-from-absolute
  999.                          (calendar-absolute-from-hebrew
  1000.                           (list month day year)))))
  1001.               (if (calendar-date-is-visible-p date)
  1002.                   (mark-visible-calendar-date date)))
  1003.           ;; Month and day in any year--this taken from the holiday stuff.
  1004.           (if (memq displayed-month;;  This test is only to speed things up a
  1005.                     (list          ;;  bit; it works fine without the test too.
  1006.                      (if (< 11 month) (- month 11) (+ month 1))
  1007.                      (if (< 10 month) (- month 10) (+ month 2))
  1008.                      (if (<  9 month) (- month  9) (+ month 3))
  1009.                      (if (<  8 month) (- month  8) (+ month 4))
  1010.                      (if (<  7 month) (- month  7) (+ month 5))))
  1011.               (let ((m1 displayed-month)
  1012.                     (y1 displayed-year)
  1013.                     (m2 displayed-month)
  1014.                     (y2 displayed-year)
  1015.                     (year))
  1016.                 (increment-calendar-month m1 y1 -1)
  1017.                 (increment-calendar-month m2 y2 1)
  1018.                 (let* ((start-date (calendar-absolute-from-gregorian
  1019.                                     (list m1 1 y1)))
  1020.                        (end-date (calendar-absolute-from-gregorian
  1021.                                   (list m2
  1022.                                         (calendar-last-day-of-month m2 y2)
  1023.                                         y2)))
  1024.                        (hebrew-start
  1025.                         (calendar-hebrew-from-absolute start-date))
  1026.                        (hebrew-end (calendar-hebrew-from-absolute end-date))
  1027.                        (hebrew-y1 (extract-calendar-year hebrew-start))
  1028.                        (hebrew-y2 (extract-calendar-year hebrew-end)))
  1029.                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
  1030.                   (let ((date (calendar-gregorian-from-absolute
  1031.                                (calendar-absolute-from-hebrew
  1032.                                 (list month day year)))))
  1033.                     (if (calendar-date-is-visible-p date)
  1034.                         (mark-visible-calendar-date date)))))))
  1035.       ;; Not one of the simple cases--check all visible dates for match.
  1036.       ;; Actually, the following code takes care of ALL of the cases, but
  1037.       ;; it's much too slow to be used for the simple (common) cases.
  1038.       (let ((m displayed-month)
  1039.             (y displayed-year)
  1040.             (first-date)
  1041.             (last-date))
  1042.         (increment-calendar-month m y -1)
  1043.         (setq first-date
  1044.               (calendar-absolute-from-gregorian
  1045.                (list m 1 y)))
  1046.         (increment-calendar-month m y 2)
  1047.         (setq last-date
  1048.               (calendar-absolute-from-gregorian
  1049.                (list m (calendar-last-day-of-month m y) y)))
  1050.         (calendar-for-loop date from first-date to last-date do
  1051.           (let* ((h-date (calendar-hebrew-from-absolute date))
  1052.                  (h-month (extract-calendar-month h-date))
  1053.                  (h-day (extract-calendar-day h-date))
  1054.                  (h-year (extract-calendar-year h-date)))
  1055.             (and (or (zerop month)
  1056.                      (= month h-month))
  1057.                  (or (zerop day)
  1058.                      (= day h-day))
  1059.                  (or (zerop year)
  1060.                      (= year h-year))
  1061.                  (mark-visible-calendar-date
  1062.                   (calendar-gregorian-from-absolute date)))))))))
  1063.  
  1064. (defun list-sexp-diary-entries (date)
  1065.   "Add sexp entries for DATE from the diary file to `diary-entries-list'.
  1066. Also, Make them visible in the diary file.  Returns t if any entries were
  1067. found.
  1068.  
  1069. Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
  1070. `%%').  The form of a sexp diary entry is
  1071.  
  1072.                   %%(SEXP) ENTRY
  1073.  
  1074. Both ENTRY and DATE are globally available when the SEXP is evaluated.  If the
  1075. SEXP yields the value nil, the diary entry does not apply.  If it yields a
  1076. non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
  1077. string, that string will be the diary entry in the fancy diary display.
  1078.  
  1079. For example, the following diary entry will apply to the 21st of the month
  1080. if it is a weekday and the Friday before if the 21st is on a weekend:
  1081.  
  1082.       &%%(let ((dayname (calendar-day-of-week date))
  1083.                (day (extract-calendar-day date)))
  1084.            (or
  1085.              (and (= day 21) (memq dayname '(1 2 3 4 5)))
  1086.              (and (memq day '(19 20)) (= dayname 5)))
  1087.          ) UIUC pay checks deposited
  1088.  
  1089. A number of built-in functions are available for this type of diary entry:
  1090.  
  1091.       %%(diary-float MONTH DAYNAME N) text
  1092.                   Entry will appear on the Nth DAYNAME of MONTH.
  1093.                   (DAYNAME=0 means Sunday, 1 means Monday, and so on;
  1094.                   if N is negative it counts backward from the end of
  1095.                   the month.  MONTH can be a list of months, a single
  1096.                   month, or t to specify all months.
  1097.  
  1098.       %%(diary-block M1 D1 Y1 M2 D2 Y2) text
  1099.                   Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
  1100.                   inclusive.  (If `european-calendar-style' is t, the
  1101.                   order of the parameters should be changed to D1, M1, Y1,
  1102.                   D2, M2, Y2.)
  1103.  
  1104.       %%(diary-countdown BEFORE AFTER M1 D1 Y1) text
  1105.                   Entry will appear on dates between BEFORE days before
  1106.                   and AFTER days after specified date.  (If
  1107.                   `european-calendar-style' is t, the order of the
  1108.                   parameters should be changed to BEFORE, AFTER, D1, M1,
  1109.                   Y1.)
  1110.  
  1111.       %%(diary-anniversary MONTH DAY YEAR) text
  1112.                   Entry will appear on anniversary dates of MONTH DAY, YEAR.
  1113.                   (If `european-calendar-style' is t, the order of the
  1114.                   parameters should be changed to DAY, MONTH, YEAR.)  Text
  1115.                   can contain %d or %d%s; %d will be replaced by the number
  1116.                   of years since the MONTH DAY, YEAR and %s will be replaced
  1117.                   by the ordinal ending of that number (that is, `st', `nd',
  1118.                   `rd' or `th', as appropriate.  The anniversary of February
  1119.                   29 is considered to be March 1 in a non-leap year.
  1120.  
  1121.       %%(diary-cyclic N MONTH DAY YEAR) text
  1122.                   Entry will appear every N days, starting MONTH DAY, YEAR.
  1123.                   (If `european-calendar-style' is t, the order of the
  1124.                   parameters should be changed to N, DAY, MONTH, YEAR.)  Text
  1125.                   can contain %d or %d%s; %d will be replaced by the number
  1126.                   of repetitions since the MONTH DAY, YEAR and %s will
  1127.                   be replaced by the ordinal ending of that number (that is,
  1128.                   `st', `nd', `rd' or `th', as appropriate.
  1129.  
  1130.       %%(diary-day-of-year)
  1131.                   Diary entries giving the day of the year and the number of
  1132.                   days remaining in the year will be made every day.  Note
  1133.                   that since there is no text, it makes sense only if the
  1134.                   fancy diary display is used.
  1135.  
  1136.       %%(diary-iso-date)
  1137.                   Diary entries giving the corresponding ISO commercial date
  1138.                   will be made every day.  Note that since there is no text,
  1139.                   it makes sense only if the fancy diary display is used.
  1140.  
  1141.       %%(diary-french-date)
  1142.                   Diary entries giving the corresponding French Revolutionary
  1143.                   date will be made every day.  Note that since there is no
  1144.                   text, it makes sense only if the fancy diary display is used.
  1145.  
  1146.       %%(diary-islamic-date)
  1147.                   Diary entries giving the corresponding Islamic date will be
  1148.                   made every day.  Note that since there is no text, it
  1149.                   makes sense only if the fancy diary display is used.
  1150.  
  1151.       %%(diary-hebrew-date)
  1152.                   Diary entries giving the corresponding Hebrew date will be
  1153.                   made every day.  Note that since there is no text, it
  1154.                   makes sense only if the fancy diary display is used.
  1155.  
  1156.       %%(diary-astro-day-number) Diary entries giving the corresponding
  1157.                   astronomical (Julian) day number will be made every day.
  1158.                   Note that since there is no text, it makes sense only if the
  1159.                   fancy diary display is used.
  1160.  
  1161.       %%(diary-julian-date) Diary entries giving the corresponding
  1162.                  Julian date will be made every day.  Note that since
  1163.                  there is no text, it makes sense only if the fancy diary
  1164.                  display is used.
  1165.  
  1166.       %%(diary-sunrise-sunset)
  1167.                   Diary entries giving the local times of sunrise and sunset
  1168.                   will be made every day.  Note that since there is no text,
  1169.                   it makes sense only if the fancy diary display is used.
  1170.                   Floating point required.
  1171.  
  1172.       %%(diary-phases-of-moon)
  1173.                   Diary entries giving the times of the phases of the moon
  1174.                   will be when appropriate.  Note that since there is no text,
  1175.                   it makes sense only if the fancy diary display is used.
  1176.                   Floating point required.
  1177.  
  1178.       %%(diary-yahrzeit MONTH DAY YEAR) text
  1179.                   Text is assumed to be the name of the person; the date is
  1180.                   the date of death on the *civil* calendar.  The diary entry
  1181.                   will appear on the proper Hebrew-date anniversary and on the
  1182.                   day before.  (If `european-calendar-style' is t, the order
  1183.                   of the parameters should be changed to DAY, MONTH, YEAR.)
  1184.                   
  1185.       %%(diary-rosh-hodesh)
  1186.                   Diary entries will be made on the dates of Rosh Hodesh on
  1187.                   the Hebrew calendar.  Note that since there is no text, it
  1188.                   makes sense only if the fancy diary display is used.
  1189.  
  1190.       %%(diary-parasha)
  1191.                   Diary entries giving the weekly parasha will be made on
  1192.                   every Saturday.  Note that since there is no text, it
  1193.                   makes sense only if the fancy diary display is used.
  1194.  
  1195.       %%(diary-omer)
  1196.                   Diary entries giving the omer count will be made every day
  1197.                   from Passover to Shavuoth.  Note that since there is no text,
  1198.                   it makes sense only if the fancy diary display is used.
  1199.  
  1200. Marking these entries is *extremely* time consuming, so these entries are
  1201. best if they are nonmarking."
  1202.   (let* ((mark (regexp-quote diary-nonmarking-symbol))
  1203.          (sexp-mark (regexp-quote sexp-diary-entry-symbol))
  1204.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
  1205.          (entry-found))
  1206.     (goto-char (point-min))
  1207.     (while (re-search-forward s-entry nil t)
  1208.       (backward-char 1)
  1209.       (let ((sexp-start (point))
  1210.             (sexp)
  1211.             (entry)
  1212.             (entry-start)
  1213.             (line-start))
  1214.         (forward-sexp)
  1215.         (setq sexp (buffer-substring sexp-start (point)))
  1216.         (save-excursion
  1217.           (re-search-backward "\^M\\|\n\\|\\`")
  1218.           (setq line-start (point)))
  1219.         (forward-char 1)
  1220.         (if (and (or (char-equal (preceding-char) ?\^M)
  1221.                      (char-equal (preceding-char) ?\n))
  1222.                  (not (looking-at " \\|\^I")))
  1223.             (progn;; Diary entry consists only of the sexp
  1224.               (backward-char 1)
  1225.               (setq entry ""))
  1226.           (setq entry-start (point))
  1227.           (re-search-forward "\^M\\|\n" nil t)
  1228.           (while (looking-at " \\|\^I")
  1229.             (re-search-forward "\^M\\|\n" nil t))
  1230.           (backward-char 1)
  1231.           (setq entry (buffer-substring entry-start (point)))
  1232.           (while (string-match "[\^M]" entry)
  1233.             (aset entry (match-beginning 0) ?\n )))
  1234.         (let ((diary-entry (diary-sexp-entry sexp entry date)))
  1235.           (if diary-entry
  1236.               (subst-char-in-region line-start (point) ?\^M ?\n t))
  1237.           (add-to-diary-list date diary-entry)
  1238.           (setq entry-found (or entry-found diary-entry)))))
  1239.     entry-found))
  1240.  
  1241. (defun diary-sexp-entry (sexp entry date)
  1242.   "Process a SEXP diary ENTRY for DATE."
  1243.   (let ((result (if calendar-debug-sexp
  1244.                   (let ((stack-trace-on-error t))
  1245.                     (eval (car (read-from-string sexp))))
  1246.                   (condition-case nil
  1247.                       (eval (car (read-from-string sexp)))
  1248.                     (error
  1249.                      (beep)
  1250.                      (message "Bad sexp at line %d in %s: %s"
  1251.                               (save-excursion
  1252.                                 (save-restriction
  1253.                                   (narrow-to-region 1 (point))
  1254.                                   (goto-char (point-min))
  1255.                                   (let ((lines 1))
  1256.                                     (while (re-search-forward "\n\\|\^M" nil t)
  1257.                                       (setq lines (1+ lines)))
  1258.                                     lines)))
  1259.                               diary-file sexp)
  1260.                      (sleep-for 2))))))
  1261.     (if (stringp result)
  1262.         result
  1263.       (if result
  1264.           entry
  1265.         nil))))
  1266.  
  1267. (defun diary-block (m1 d1 y1 m2 d2 y2)
  1268.   "Block diary entry.
  1269. Entry applies if date is between two dates.  Order of the parameters is
  1270. M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and
  1271. D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
  1272.   (let ((date1 (calendar-absolute-from-gregorian
  1273.                 (if european-calendar-style
  1274.                     (list d1 m1 y1)
  1275.                   (list m1 d1 y1))))
  1276.         (date2 (calendar-absolute-from-gregorian
  1277.                 (if european-calendar-style
  1278.                     (list d2 m2 y2)
  1279.                   (list m2 d2 y2))))
  1280.         (d (calendar-absolute-from-gregorian date)))
  1281.     (if (and (<= date1 d) (<= d date2))
  1282.         entry)))
  1283.  
  1284. (defun diary-countdown (before after m1 d1 y1)
  1285.   "Countdown diary entry.
  1286. Entry applies if date is between BEFORE days before and AFTER days after
  1287. specified date.  Order of the parameters is BEFORE, AFTER, M1, D1, Y1 if
  1288. `european-calendar-style' is nil, and BEFORE, AFTER, D1, M1, Y1 if
  1289. `european-calendar-style' is t."
  1290.   (let* ((date1 (calendar-absolute-from-gregorian
  1291.                  (if european-calendar-style
  1292.                      (list d1 m1 y1)
  1293.                    (list m1 d1 y1))))
  1294.          (d (calendar-absolute-from-gregorian date))
  1295.          (diff (- d date1)))
  1296.     (cond
  1297.      ((and (<= (- before) diff) (< diff 0))
  1298.       (concat (format "It is %d day%s before " 
  1299.                       (- diff) (if (= diff -1) "" "s")) entry))
  1300.      ((= diff 0) (concat (format "TODAY: " diff) entry))
  1301.      ((and (<= diff after) (> diff 0)) 
  1302.       (concat (format "It is %d day%s after " 
  1303.                       diff (if (= diff 1) "" "s")) entry))
  1304.      (t nil))))
  1305.  
  1306. (defun diary-float (month dayname n)
  1307.   "Floating diary entry--entry applies if date is the nth dayname of month.
  1308. Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
  1309. t, or an integer.  The constant t means all months.  If N is negative, count
  1310. backward from the end of the month."
  1311.   (let ((m (extract-calendar-month date))
  1312.         (y (extract-calendar-year date)))
  1313.     (if (and
  1314.          (or (and (listp month) (memq m month))
  1315.              (equal m month)
  1316.              (eq month t))
  1317.          (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
  1318.         entry)))
  1319.  
  1320. (defun diary-anniversary (month day year)
  1321.   "Anniversary diary entry.
  1322. Entry applies if date is the anniversary of MONTH, DAY, YEAR if
  1323. `european-calendar-style' is nil, and DAY, MONTH, YEAR if
  1324. `european-calendar-style' is t.  Diary entry can contain `%d' or `%d%s'; the
  1325. %d will be replaced by the number of years since the MONTH DAY, YEAR and the
  1326. %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
  1327. `rd' or `th', as appropriate.  The anniversary of February 29 is considered
  1328. to be March 1 in non-leap years."
  1329.   (let* ((d (if european-calendar-style
  1330.                 month
  1331.               day))
  1332.          (m (if european-calendar-style
  1333.                 day
  1334.               month))
  1335.          (y (extract-calendar-year date))
  1336.          (diff (- y year)))
  1337.     (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
  1338.         (setq m 3
  1339.               d 1))
  1340.     (if (and (> diff 0) (calendar-date-equal (list m d y) date))
  1341.         (format entry diff (diary-ordinal-suffix diff)))))
  1342.  
  1343. (defun diary-cyclic (n month day year)
  1344.   "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
  1345. If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
  1346. ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
  1347. years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
  1348. ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
  1349.   (let* ((d (if european-calendar-style
  1350.                 month
  1351.               day))
  1352.          (m (if european-calendar-style
  1353.                 day
  1354.               month))
  1355.          (diff (- (calendar-absolute-from-gregorian date)
  1356.                   (calendar-absolute-from-gregorian
  1357.                    (list m d year))))
  1358.          (cycle (/ diff n)))
  1359.     (if (and (>= diff 0) (zerop (% diff n)))
  1360.         (format entry cycle (diary-ordinal-suffix cycle)))))
  1361.  
  1362. (defun diary-ordinal-suffix (n)
  1363.   "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
  1364.   (if (or (memq (% n 100) '(11 12 13))
  1365.           (< 3 (% n 10)))
  1366.       "th"
  1367.     (aref ["th" "st" "nd" "rd"] (% n 10))))
  1368.  
  1369. (defun diary-day-of-year ()
  1370.   "Day of year and number of days remaining in the year of date diary entry."
  1371.   (calendar-day-of-year-string date))
  1372.  
  1373. (defun diary-iso-date ()
  1374.   "ISO calendar equivalent of date diary entry."
  1375.   (format "ISO date: %s" (calendar-iso-date-string date)))
  1376.  
  1377. (defun diary-islamic-date ()
  1378.   "Islamic calendar equivalent of date diary entry."
  1379.   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
  1380.     (if (string-equal i "")
  1381.         "Date is pre-Islamic"
  1382.       (format "Islamic date (until sunset): %s" i))))
  1383.  
  1384. (defun diary-hebrew-date ()
  1385.   "Hebrew calendar equivalent of date diary entry."
  1386.   (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
  1387.  
  1388. (defun diary-julian-date ()
  1389.   "Julian calendar equivalent of date diary entry."
  1390.   (format "Julian date: %s" (calendar-julian-date-string date)))
  1391.  
  1392. (defun diary-astro-day-number ()
  1393.   "Astronomical (Julian) day number diary entry."
  1394.   (format "Astronomical (Julian) day number %s"
  1395.           (calendar-astro-date-string date)))
  1396.  
  1397. (defun diary-omer ()
  1398.   "Omer count diary entry.
  1399. Entry applies if date is within 50 days after Passover."
  1400.   (let* ((passover
  1401.           (calendar-absolute-from-hebrew
  1402.            (list 1 15 (+ (extract-calendar-year date) 3760))))
  1403.          (omer (- (calendar-absolute-from-gregorian date) passover))
  1404.          (week (/ omer 7))
  1405.          (day (% omer 7)))
  1406.     (if (and (> omer 0) (< omer 50))
  1407.         (format "Day %d%s of the omer (until sunset)"
  1408.                 omer
  1409.                 (if (zerop week)
  1410.                     ""
  1411.                   (format ", that is, %d week%s%s"
  1412.                           week
  1413.                           (if (= week 1) "" "s")
  1414.                           (if (zerop day)
  1415.                               ""
  1416.                             (format " and %d day%s"
  1417.                                     day (if (= day 1) "" "s")))))))))
  1418.  
  1419. (defun diary-yahrzeit (death-month death-day death-year)
  1420.   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
  1421. Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
  1422. to be the name of the person.  Date of death is on the *civil* calendar;
  1423. although the date of death is specified by the civil calendar, the proper
  1424. Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
  1425. order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
  1426.   (let* ((h-date (calendar-hebrew-from-absolute
  1427.                   (calendar-absolute-from-gregorian
  1428.                    (if european-calendar-style
  1429.                        (list death-day death-month death-year)
  1430.                    (list death-month death-day death-year)))))
  1431.          (h-month (extract-calendar-month h-date))
  1432.          (h-day (extract-calendar-day h-date))
  1433.          (h-year (extract-calendar-year h-date))
  1434.          (d (calendar-absolute-from-gregorian date))
  1435.          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
  1436.          (diff (- yr h-year))
  1437.          (y (hebrew-calendar-yahrzeit h-date yr)))
  1438.     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
  1439.         (format "Yahrzeit of %s%s: %d%s anniversary"
  1440.                 entry
  1441.                 (if (= y d) "" " (evening)")
  1442.                 diff
  1443.                 (cond ((= (% diff 10) 1) "st")
  1444.                       ((= (% diff 10) 2) "nd")
  1445.                       ((= (% diff 10) 3) "rd")
  1446.                       (t "th"))))))
  1447.  
  1448. (defun diary-rosh-hodesh ()
  1449.   "Rosh Hodesh diary entry.
  1450. Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
  1451.   (let* ((d (calendar-absolute-from-gregorian date))
  1452.          (h-date (calendar-hebrew-from-absolute d))
  1453.          (h-month (extract-calendar-month h-date))
  1454.          (h-day (extract-calendar-day h-date))
  1455.          (h-year (extract-calendar-year h-date))
  1456.          (leap-year (hebrew-calendar-leap-year-p h-year))
  1457.          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
  1458.          (h-month-names
  1459.           (if leap-year
  1460.               calendar-hebrew-month-name-array-leap-year
  1461.             calendar-hebrew-month-name-array-common-year))
  1462.          (this-month (aref h-month-names (1- h-month)))
  1463.          (h-yesterday (extract-calendar-day
  1464.                        (calendar-hebrew-from-absolute (1- d)))))
  1465.     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
  1466.         (format
  1467.          "Rosh Hodesh %s"
  1468.          (if (= h-day 30)
  1469.              (format
  1470.               "%s (first day)"
  1471.               ;; next month must be in the same year since this
  1472.               ;; month can't be the last month of the year since
  1473.               ;; it has 30 days
  1474.               (aref h-month-names h-month))
  1475.            (if (= h-yesterday 30)
  1476.                (format "%s (second day)" this-month)
  1477.              this-month)))
  1478.       (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
  1479.           (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
  1480.                  (format "Mevarhim Rosh Hodesh %s (%s)"
  1481.                          (aref h-month-names
  1482.                                (if (= h-month
  1483.                                       (hebrew-calendar-last-month-of-year
  1484.                                        h-year))
  1485.                                    0 h-month))
  1486.                          (aref calendar-day-name-array (- 29 h-day))))
  1487.                 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
  1488.                  (format "Mevarhim Rosh Hodesh %s (%s-%s)"
  1489.                          (aref h-month-names h-month)
  1490.                          (if (= h-day 29)
  1491.                              "tomorrow"
  1492.                            (aref calendar-day-name-array (- 29 h-day)))
  1493.                          (aref calendar-day-name-array
  1494.                                (% (- 30 h-day) 7)))))
  1495.         (if (and (= h-day 29) (/= h-month 6))
  1496.             (format "Erev Rosh Hodesh %s"
  1497.                     (aref h-month-names
  1498.                           (if (= h-month
  1499.                                  (hebrew-calendar-last-month-of-year
  1500.                                   h-year))
  1501.                               0 h-month))))))))
  1502.  
  1503. (defun diary-parasha ()
  1504.   "Parasha diary entry--entry applies if date is a Saturday."
  1505.   (let ((d (calendar-absolute-from-gregorian date)))
  1506.     (if (= (% d 7) 6);;  Saturday
  1507.         (let*
  1508.             ((h-year (extract-calendar-year
  1509.                       (calendar-hebrew-from-absolute d)))
  1510.              (rosh-hashannah
  1511.               (calendar-absolute-from-hebrew (list 7 1 h-year)))
  1512.              (passover
  1513.               (calendar-absolute-from-hebrew (list 1 15 h-year)))
  1514.              (rosh-hashannah-day
  1515.               (aref calendar-day-name-array (% rosh-hashannah 7)))
  1516.              (passover-day
  1517.               (aref calendar-day-name-array (% passover 7)))
  1518.              (long-h (hebrew-calendar-long-heshvan-p h-year))
  1519.              (short-k (hebrew-calendar-short-kislev-p h-year))
  1520.              (type (cond ((and long-h (not short-k)) "complete")
  1521.                          ((and (not long-h) short-k) "incomplete")
  1522.                          (t "regular")))
  1523.              (year-format
  1524.               (symbol-value
  1525.                (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
  1526.                                rosh-hashannah-day type passover-day))))
  1527.              (first-saturday;; of Hebrew year
  1528.               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
  1529.              (saturday;; which Saturday of the Hebrew year
  1530.               (/ (- d first-saturday) 7))
  1531.              (parasha (aref year-format saturday)))
  1532.           (if parasha
  1533.               (format
  1534.                "Parashat %s"
  1535.                (if (listp parasha);; Israel differs from diaspora
  1536.                    (if (car parasha)
  1537.                        (format "%s (diaspora), %s (Israel)"
  1538.                                (hebrew-calendar-parasha-name (car parasha))
  1539.                                (hebrew-calendar-parasha-name (cdr parasha)))
  1540.                      (format "%s (Israel)"
  1541.                              (hebrew-calendar-parasha-name (cdr parasha))))
  1542.                  (hebrew-calendar-parasha-name parasha))))))))
  1543.  
  1544. (defun add-to-diary-list (date string)
  1545.   "Add the entry (DATE STRING) to `diary-entries-list'.
  1546. Do nothing if DATE or STRING is nil."
  1547.   (and date string
  1548.        (setq diary-entries-list 
  1549.              (append diary-entries-list (list (list date string))))))
  1550.  
  1551. (defvar hebrew-calendar-parashiot-names
  1552. ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
  1553.  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
  1554.  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
  1555.  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
  1556.  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
  1557.  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
  1558.  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
  1559.  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
  1560.  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
  1561.   "The names of the parashiot in the Torah.")
  1562.  
  1563. ;; The seven ordinary year types (keviot)
  1564.  
  1565. (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
  1566.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1567.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1568.     43 44 45 46 47 48 49 50]
  1569.   "The structure of the parashiot.
  1570. Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
  1571. 29 days), and has Passover start on Sunday.")
  1572.  
  1573. (defconst hebrew-calendar-year-Saturday-complete-Tuesday
  1574.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1575.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1576.     43 44 45 46 47 48 49 [50 51]]
  1577.   "The structure of the parashiot.
  1578. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1579. have 30 days), and has Passover start on Tuesday.")
  1580.  
  1581. (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
  1582.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1583.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1584.     43 44 45 46 47 48 49 [50 51]]
  1585.   "The structure of the parashiot.
  1586. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1587. have 29 days), and has Passover start on Tuesday.")
  1588.  
  1589. (defconst hebrew-calendar-year-Monday-complete-Thursday
  1590.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1591.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1592.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1593.   "The structure of the parashiot.
  1594. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1595. 30 days), and has Passover start on Thursday.")
  1596.  
  1597. (defconst hebrew-calendar-year-Tuesday-regular-Thursday
  1598.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1599.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1600.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1601.   "The structure of the parashiot.
  1602. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1603. Kislev has 30 days), and has Passover start on Thursday.")
  1604.  
  1605. (defconst hebrew-calendar-year-Thursday-regular-Saturday
  1606.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
  1607.    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
  1608.    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
  1609.    49 50]
  1610.   "The structure of the parashiot.
  1611. Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
  1612. Kislev has 30 days), and has Passover start on Saturday.")
  1613.  
  1614. (defconst hebrew-calendar-year-Thursday-complete-Sunday
  1615.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1616.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1617.     43 44 45 46 47 48 49 50]
  1618.   "The structure of the parashiot.
  1619. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
  1620. have 30 days), and has Passover start on Sunday.")
  1621.  
  1622. ;; The seven leap year types (keviot)
  1623.  
  1624. (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
  1625.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1626.     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
  1627.     43 44 45 46 47 48 49 [50 51]]
  1628.   "The structure of the parashiot.
  1629. Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
  1630. have 29 days), and has Passover start on Tuesday.")
  1631.  
  1632. (defconst hebrew-calendar-year-Saturday-complete-Thursday
  1633.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1634.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1635.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1636.   "The structure of the parashiot.
  1637. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1638. have 30 days), and has Passover start on Thursday.")
  1639.  
  1640. (defconst hebrew-calendar-year-Monday-incomplete-Thursday
  1641.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1642.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1643.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1644.   "The structure of the parashiot.
  1645. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1646. have 29 days), and has Passover start on Thursday.")
  1647.  
  1648. (defconst hebrew-calendar-year-Monday-complete-Saturday
  1649.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1650.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1651.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1652.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1653.   "The structure of the parashiot.
  1654. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1655. 30 days), and has Passover start on Saturday.")
  1656.  
  1657. (defconst hebrew-calendar-year-Tuesday-regular-Saturday
  1658.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1659.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1660.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1661.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1662.   "The structure of the parashiot.
  1663. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1664. Kislev has 30 days), and has Passover start on Saturday.")
  1665.  
  1666. (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
  1667.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1668.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1669.     43 44 45 46 47 48 49 50]
  1670.   "The structure of the parashiot.
  1671. Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
  1672. have 29 days), and has Passover start on Sunday.")
  1673.  
  1674. (defconst hebrew-calendar-year-Thursday-complete-Tuesday
  1675.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1676.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1677.     43 44 45 46 47 48 49 [50 51]]
  1678.   "The structure of the parashiot.
  1679. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
  1680. have 30 days), and has Passover start on Tuesday.")
  1681.  
  1682. (defun hebrew-calendar-parasha-name (p)
  1683.   "Name(s) corresponding to parasha P."
  1684.   (if (arrayp p);; combined parasha
  1685.       (format "%s/%s"
  1686.               (aref hebrew-calendar-parashiot-names (aref p 0))
  1687.               (aref hebrew-calendar-parashiot-names (aref p 1)))
  1688.     (aref hebrew-calendar-parashiot-names p)))
  1689.  
  1690. (defun list-islamic-diary-entries ()
  1691.   "Add any Islamic date entries from the diary file to `diary-entries-list'.
  1692. Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
  1693. \(normally an `I').  The same diary date forms govern the style of the Islamic
  1694. calendar entries, except that the Islamic month names must be spelled in full.
  1695. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1696. Dhu al-Hijjah.  If an Islamic date diary entry begins with a
  1697. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  1698. not be marked in the calendar.  This function is provided for use with the
  1699. `nongregorian-diary-listing-hook'."
  1700.   (if (< 0 number)
  1701.       (let ((buffer-read-only nil)
  1702.             (diary-modified (buffer-modified-p))
  1703.             (gdate original-date)
  1704.             (mark (regexp-quote diary-nonmarking-symbol)))
  1705.         (calendar-for-loop i from 1 to number do
  1706.            (let* ((d diary-date-forms)
  1707.                   (idate (calendar-islamic-from-absolute 
  1708.                           (calendar-absolute-from-gregorian gdate)))
  1709.                   (month (extract-calendar-month idate))
  1710.                   (day (extract-calendar-day idate))
  1711.                   (year (extract-calendar-year idate)))
  1712.              (while d
  1713.                (let*
  1714.                    ((date-form (if (equal (car (car d)) 'backup)
  1715.                                    (cdr (car d))
  1716.                                  (car d)))
  1717.                     (backup (equal (car (car d)) 'backup))
  1718.                     (dayname
  1719.                      (concat
  1720.                       (calendar-day-name gdate) "\\|"
  1721.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  1722.                     (calendar-month-name-array
  1723.                      calendar-islamic-month-name-array)
  1724.                     (monthname
  1725.                      (concat
  1726.                       "\\*\\|"
  1727.                       (calendar-month-name month)))
  1728.                     (month (concat "\\*\\|0*" (int-to-string month)))
  1729.                     (day (concat "\\*\\|0*" (int-to-string day)))
  1730.                     (year
  1731.                      (concat
  1732.                       "\\*\\|0*" (int-to-string year)
  1733.                       (if abbreviated-calendar-year
  1734.                           (concat "\\|" (int-to-string (% year 100)))
  1735.                         "")))
  1736.                     (regexp
  1737.                      (concat
  1738.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  1739.                       (regexp-quote islamic-diary-entry-symbol)
  1740.                       "\\("
  1741.                       (mapconcat 'eval date-form "\\)\\(")
  1742.                       "\\)"))
  1743.                     (case-fold-search t))
  1744.                  (goto-char (point-min))
  1745.                  (while (re-search-forward regexp nil t)
  1746.                    (if backup (re-search-backward "\\<" nil t))
  1747.                    (if (and (or (char-equal (preceding-char) ?\^M)
  1748.                                 (char-equal (preceding-char) ?\n))
  1749.                             (not (looking-at " \\|\^I")))
  1750.                        ;;  Diary entry that consists only of date.
  1751.                        (backward-char 1)
  1752.                      ;;  Found a nonempty diary entry--make it visible and
  1753.                      ;;  add it to the list.
  1754.                      (let ((entry-start (point))
  1755.                            (date-start))
  1756.                        (re-search-backward "\^M\\|\n\\|\\`")
  1757.                        (setq date-start (point))
  1758.                        (re-search-forward "\^M\\|\n" nil t 2)
  1759.                        (while (looking-at " \\|\^I")
  1760.                          (re-search-forward "\^M\\|\n" nil t))
  1761.                        (backward-char 1)
  1762.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  1763.                        (add-to-diary-list
  1764.                          gdate (buffer-substring entry-start (point)))))))
  1765.                (setq d (cdr d))))
  1766.            (setq gdate
  1767.                  (calendar-gregorian-from-absolute
  1768.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  1769.            (set-buffer-modified-p diary-modified))
  1770.         (goto-char (point-min))))
  1771.  
  1772. (defun mark-islamic-diary-entries ()
  1773.   "Mark days in the calendar window that have Islamic date diary entries.
  1774. Each entry in diary-file (or included files) visible in the calendar window
  1775. is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
  1776. \(normally an `I').  The same diary-date-forms govern the style of the Islamic
  1777. calendar entries, except that the Islamic month names must be spelled in full.
  1778. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1779. Dhu al-Hijjah.  Islamic date diary entries that begin with a
  1780. diary-nonmarking-symbol will not be marked in the calendar.  This function is
  1781. provided for use as part of the nongregorian-diary-marking-hook."
  1782.   (let ((d diary-date-forms))
  1783.     (while d
  1784.       (let*
  1785.           ((date-form (if (equal (car (car d)) 'backup)
  1786.                           (cdr (car d))
  1787.                         (car d)));; ignore 'backup directive
  1788.            (dayname (diary-name-pattern calendar-day-name-array))
  1789.            (monthname
  1790.             (concat
  1791.              (diary-name-pattern calendar-islamic-month-name-array t)
  1792.              "\\|\\*"))
  1793.            (month "[0-9]+\\|\\*")
  1794.            (day "[0-9]+\\|\\*")
  1795.            (year "[0-9]+\\|\\*")
  1796.            (l (length date-form))
  1797.            (d-name-pos (- l (length (memq 'dayname date-form))))
  1798.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  1799.            (m-name-pos (- l (length (memq 'monthname date-form))))
  1800.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  1801.            (d-pos (- l (length (memq 'day date-form))))
  1802.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  1803.            (m-pos (- l (length (memq 'month date-form))))
  1804.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  1805.            (y-pos (- l (length (memq 'year date-form))))
  1806.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  1807.            (regexp
  1808.             (concat
  1809.              "\\(\\`\\|\^M\\|\n\\)"
  1810.              (regexp-quote islamic-diary-entry-symbol)
  1811.              "\\("
  1812.              (mapconcat 'eval date-form "\\)\\(")
  1813.              "\\)"))
  1814.            (case-fold-search t))
  1815.         (goto-char (point-min))
  1816.         (while (re-search-forward regexp nil t)
  1817.           (let* ((dd-name
  1818.                   (if d-name-pos
  1819.                       (buffer-substring
  1820.                        (match-beginning d-name-pos)
  1821.                        (match-end d-name-pos))))
  1822.                  (mm-name
  1823.                   (if m-name-pos
  1824.                       (buffer-substring
  1825.                        (match-beginning m-name-pos)
  1826.                        (match-end m-name-pos))))
  1827.                  (mm (string-to-int
  1828.                       (if m-pos
  1829.                           (buffer-substring
  1830.                            (match-beginning m-pos)
  1831.                            (match-end m-pos))
  1832.                         "")))
  1833.                  (dd (string-to-int
  1834.                       (if d-pos
  1835.                           (buffer-substring
  1836.                            (match-beginning d-pos)
  1837.                            (match-end d-pos))
  1838.                         "")))
  1839.                  (y-str (if y-pos
  1840.                             (buffer-substring
  1841.                              (match-beginning y-pos)
  1842.                              (match-end y-pos))))
  1843.                  (yy (if (not y-str)
  1844.                          0
  1845.                        (if (and (= (length y-str) 2)
  1846.                                 abbreviated-calendar-year)
  1847.                            (let* ((current-y
  1848.                                    (extract-calendar-year
  1849.                                     (calendar-islamic-from-absolute
  1850.                                      (calendar-absolute-from-gregorian
  1851.                                       (calendar-current-date)))))
  1852.                                   (y (+ (string-to-int y-str)
  1853.                                         (* 100 (/ current-y 100)))))
  1854.                              (if (> (- y current-y) 50)
  1855.                                  (- y 100)
  1856.                                (if (> (- current-y y) 50)
  1857.                                    (+ y 100)
  1858.                                  y)))
  1859.                          (string-to-int y-str)))))
  1860.             (if dd-name
  1861.                 (mark-calendar-days-named
  1862.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  1863.                              (calendar-make-alist
  1864.                                calendar-day-name-array
  1865.                                0
  1866.                                '(lambda (x) (substring x 0 3))))))
  1867.               (if mm-name
  1868.                   (if (string-equal mm-name "*")
  1869.                       (setq mm 0)
  1870.                     (setq mm
  1871.                           (cdr (assoc
  1872.                                 (capitalize mm-name)
  1873.                                 (calendar-make-alist
  1874.                                   calendar-islamic-month-name-array))))))
  1875.               (mark-islamic-calendar-date-pattern mm dd yy)))))
  1876.       (setq d (cdr d)))))
  1877.  
  1878. (defun mark-islamic-calendar-date-pattern (month day year)
  1879.   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
  1880. A value of 0 in any position is a wildcard."
  1881.   (save-excursion
  1882.     (set-buffer calendar-buffer)
  1883.     (if (and (/= 0 month) (/= 0 day))
  1884.         (if (/= 0 year)
  1885.             ;; Fully specified Islamic date.
  1886.             (let ((date (calendar-gregorian-from-absolute
  1887.                          (calendar-absolute-from-islamic
  1888.                           (list month day year)))))
  1889.               (if (calendar-date-is-visible-p date)
  1890.                   (mark-visible-calendar-date date)))
  1891.           ;; Month and day in any year--this taken from the holiday stuff.
  1892.           (let* ((islamic-date (calendar-islamic-from-absolute
  1893.                                 (calendar-absolute-from-gregorian
  1894.                                  (list displayed-month 15 displayed-year))))
  1895.                  (m (extract-calendar-month islamic-date))
  1896.                  (y (extract-calendar-year islamic-date))
  1897.                  (date))
  1898.             (if (< m 1)
  1899.                 nil;;   Islamic calendar doesn't apply.
  1900.               (increment-calendar-month m y (- 10 month))
  1901.               (if (> m 7);;  Islamic date might be visible
  1902.                   (let ((date (calendar-gregorian-from-absolute
  1903.                                (calendar-absolute-from-islamic
  1904.                                 (list month day y)))))
  1905.                     (if (calendar-date-is-visible-p date)
  1906.                         (mark-visible-calendar-date date)))))))
  1907.       ;; Not one of the simple cases--check all visible dates for match.
  1908.       ;; Actually, the following code takes care of ALL of the cases, but
  1909.       ;; it's much too slow to be used for the simple (common) cases.
  1910.       (let ((m displayed-month)
  1911.             (y displayed-year)
  1912.             (first-date)
  1913.             (last-date))
  1914.         (increment-calendar-month m y -1)
  1915.         (setq first-date
  1916.               (calendar-absolute-from-gregorian
  1917.                (list m 1 y)))
  1918.         (increment-calendar-month m y 2)
  1919.         (setq last-date
  1920.               (calendar-absolute-from-gregorian
  1921.                (list m (calendar-last-day-of-month m y) y)))
  1922.         (calendar-for-loop date from first-date to last-date do
  1923.           (let* ((i-date (calendar-islamic-from-absolute date))
  1924.                  (i-month (extract-calendar-month i-date))
  1925.                  (i-day (extract-calendar-day i-date))
  1926.                  (i-year (extract-calendar-year i-date)))
  1927.             (and (or (zerop month)
  1928.                      (= month i-month))
  1929.                  (or (zerop day)
  1930.                      (= day i-day))
  1931.                  (or (zerop year)
  1932.                      (= year i-year))
  1933.                  (mark-visible-calendar-date
  1934.                   (calendar-gregorian-from-absolute date)))))))))
  1935.  
  1936. (provide 'diary-lib)
  1937.  
  1938. ;;; diary-lib.el ends here
  1939.